home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 376-400 / disk_386 / xlispstat / src1.lzh / XLisp / xlstruct.c < prev    next >
C/C++ Source or Header  |  1990-10-03  |  11KB  |  446 lines
  1. /* xlstruct.c - the defstruct facility */
  2. /* Copyright (c) 1989, by David Michael Betz.                            */
  3. /* You may give out copies of this software; for conditions see the file */
  4. /* COPYING included with this distribution.                              */
  5.  
  6. #include <string.h>
  7. #include "xlisp.h"
  8. #include "osdef.h"
  9. #ifdef ANSI
  10. #include "xlproto.h"
  11. #else
  12. #include "xlfun.h"
  13. #endif ANSI
  14. #include "xlvar.h"
  15.  
  16. /* local variables */
  17. static char prefix[STRMAX+1]; /* type added JKL */
  18.  
  19. /* forward declarations */
  20. #ifdef ANSI
  21. void addslot(LVAL,LVAL,int,LVAL *,LVAL *),updateslot(LVAL,LVAL,LVAL);
  22. #else
  23. void addslot(),updateslot();
  24. #endif
  25.  
  26. /* xmkstruct - the '%make-struct' function */
  27. LVAL xmkstruct()
  28. {
  29.     LVAL type,val;
  30.     int i;
  31.  
  32.     /* get the structure type */
  33.     type = xlgasymbol();
  34.  
  35.     /* make the structure */
  36.     val = newstruct(type,xlargc);
  37.  
  38.     /* store each argument */
  39.     for (i = 1; moreargs(); ++i)
  40.     setelement(val,i,nextarg());
  41.     xllastarg();
  42.  
  43.     /* return the structure */
  44.     return (val);
  45. }
  46.  
  47. /* xcpystruct - the '%copy-struct' function */
  48. LVAL xcpystruct()
  49. {
  50.     LVAL str,val;
  51.     int size,i;
  52.     str = xlgastruct();
  53.     xllastarg();
  54.     size = getsize(str);
  55.     val = newstruct(getelement(str,0),size-1);
  56.     for (i = 1; i < size; ++i)
  57.     setelement(val,i,getelement(str,i));
  58.     return (val);
  59. }
  60.  
  61. /* xstrref - the '%struct-ref' function */
  62. LVAL xstrref()
  63. {
  64.     LVAL str,val;
  65.     int i;
  66.     str = xlgastruct();
  67.     val = xlgafixnum(); i = (int)getfixnum(val);
  68.     xllastarg();
  69.     return (getelement(str,i));
  70. }
  71.  
  72. /* xstrset - the '%struct-set' function */
  73. LVAL xstrset()
  74. {
  75.     LVAL str,val;
  76.     int i;
  77.     str = xlgastruct();
  78.     val = xlgafixnum(); i = (int)getfixnum(val);
  79.     val = xlgetarg();
  80.     xllastarg();
  81.     setelement(str,i,val);
  82.     return (val);
  83. }
  84.  
  85. /* xstrtypep - the '%struct-type-p' function */
  86. LVAL xstrtypep()
  87. {
  88.     LVAL type,val;
  89.     type = xlgasymbol();
  90.     val = xlgetarg();
  91.     xllastarg();
  92.     return (structp(val) && getelement(val,0) == type ? true : NIL);
  93. }
  94.  
  95. /* xdefstruct - the 'defstruct' special form */
  96. LVAL xdefstruct()
  97. {
  98.     LVAL structname,slotname,defexpr,sym,tmp,args,body;
  99.     LVAL options,oargs,slots;
  100.     char *pname;
  101.     int slotn;
  102.     
  103.     /* protect some pointers */
  104.     xlstkcheck(6);
  105.     xlsave(structname);
  106.     xlsave(slotname);
  107.     xlsave(defexpr);
  108.     xlsave(args);
  109.     xlsave(body);
  110.     xlsave(tmp);
  111.     
  112.     /* initialize */
  113.     /*args = body = NIL; initialized in macro JKL */ 
  114.     slotn = 0;
  115.  
  116.     /* get the structure name */
  117.     tmp = xlgetarg();
  118.     if (symbolp(tmp)) {
  119.     structname = tmp;
  120.     strcpy(prefix,getstring(getpname(structname)));
  121.     strcat(prefix,"-");
  122.     }
  123.  
  124.     /* get the structure name and options */
  125.     else if (consp(tmp) && symbolp(car(tmp))) {
  126.     structname = car(tmp);
  127.     strcpy(prefix,getstring(getpname(structname)));
  128.     strcat(prefix,"-");
  129.  
  130.     /* handle the list of options */
  131.     for (options = cdr(tmp); consp(options); options = cdr(options)) {
  132.  
  133.         /* get the next argument */
  134.         tmp = car(options);
  135.         
  136.         /* handle options that don't take arguments */
  137.         if (symbolp(tmp)) {
  138.         /* pname = (char *)  getstring(getpname(tmp)); not used JKL */
  139.         xlerror("unknown option",tmp);
  140.         }
  141.  
  142.         /* handle options that take arguments */
  143.         else if (consp(tmp) && symbolp(car(tmp))) {
  144.         pname = (char *) getstring(getpname(car(tmp)));
  145.         oargs = cdr(tmp);
  146.  
  147.         /* check for the :CONC-NAME keyword */
  148.         if (strcmp(pname,":CONC-NAME") == 0) {
  149.  
  150.             /* get the name of the structure to include */
  151.             if (!consp(oargs) || !symbolp(car(oargs)))
  152.             xlerror("expecting a symbol",oargs);
  153.  
  154.             /* save the prefix */
  155.             strcpy(prefix,getstring(getpname(car(oargs))));
  156.         }
  157.  
  158.         /* check for the :INCLUDE keyword */
  159.         else if (strcmp(pname,":INCLUDE") == 0) {
  160.  
  161.             /* get the name of the structure to include */
  162.             if (!consp(oargs) || !symbolp(car(oargs)))
  163.             xlerror("expecting a structure name",oargs);
  164.             tmp = car(oargs);
  165.             oargs = cdr(oargs);
  166.  
  167.             /* add each slot from the included structure */
  168.             slots = xlgetprop(tmp,xlenter("*STRUCT-SLOTS*"));
  169.             for (; consp(slots); slots = cdr(slots)) {
  170.             if (consp(car(slots)) && consp(cdr(car(slots)))) {
  171.  
  172.                 /* get the next slot description */
  173.                 tmp = car(slots);
  174.  
  175.                 /* create the slot access functions */
  176.                 addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body);
  177.             }
  178.             }
  179.  
  180.             /* handle slot initialization overrides */
  181.             for (; consp(oargs); oargs = cdr(oargs)) {
  182.             tmp = car(oargs);
  183.             if (symbolp(tmp)) {
  184.                 slotname = tmp;
  185.                 defexpr = NIL;
  186.             }
  187.             else if (consp(tmp) && symbolp(car(tmp))) {
  188.                 slotname = car(tmp);
  189.                 defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
  190.             }
  191.             else
  192.                 xlerror("bad slot description",tmp);
  193.             updateslot(args,slotname,defexpr);
  194.             }
  195.         }
  196.         else
  197.             xlerror("unknown option",tmp);
  198.         }
  199.         else
  200.         xlerror("bad option syntax",tmp);
  201.     }
  202.     }
  203.  
  204.     /* get each of the structure members */
  205.     while (moreargs()) {
  206.     
  207.     /* get the slot name and default value expression */
  208.     tmp = xlgetarg();
  209.     if (symbolp(tmp)) {
  210.         slotname = tmp;
  211.         defexpr = NIL;
  212.     }
  213.     else if (consp(tmp) && symbolp(car(tmp))) {
  214.         slotname = car(tmp);
  215.         defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
  216.     }
  217.     else
  218.         xlerror("bad slot description",tmp);
  219.     
  220.     /* create a closure for non-trival default expressions */
  221.     if (defexpr != NIL) {
  222.         tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
  223.         setbody(tmp,cons(defexpr,NIL));
  224.         tmp = cons(tmp,NIL);
  225.         defexpr = tmp;
  226.     }
  227.  
  228.     /* create the slot access functions */
  229.     addslot(slotname,defexpr,++slotn,&args,&body);
  230.     }
  231.     
  232.     /* store the slotnames and default expressions */
  233.     xlputprop(structname,args,xlenter("*STRUCT-SLOTS*"));
  234.  
  235.     /* enter the MAKE-xxx symbol */
  236.     sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
  237.     sym = xlenter(buf);
  238.  
  239.     /* make the MAKE-xxx function */
  240.     args = cons(lk_key,args);
  241.     tmp = cons(structname,NIL);
  242.     tmp = cons(s_quote,tmp);
  243.     body = cons(tmp,body);
  244.     body = cons(xlenter("%MAKE-STRUCT"),body);
  245.     body = cons(body,NIL);
  246.     setfunction(sym,
  247.         xlclose(sym,s_lambda,args,body,xlenv,xlfenv));
  248.  
  249.     /* enter the xxx-P symbol */
  250.     sprintf(buf,"%s-P",getstring(getpname(structname)));
  251.     sym = xlenter(buf);
  252.  
  253.     /* make the xxx-P function */
  254.     args = cons(xlenter("X"),NIL);
  255.     body = cons(xlenter("X"),NIL);
  256.     tmp = cons(structname,NIL);
  257.     tmp = cons(s_quote,tmp);
  258.     body = cons(tmp,body);
  259.     body = cons(xlenter("%STRUCT-TYPE-P"),body);
  260.     body = cons(body,NIL);
  261.     setfunction(sym,
  262.         xlclose(sym,s_lambda,args,body,NIL,NIL));
  263.  
  264.     /* enter the COPY-xxx symbol */
  265.     sprintf(buf,"COPY-%s",getstring(getpname(structname)));
  266.     sym = xlenter(buf);
  267.  
  268.     /* make the COPY-xxx function */
  269.     args = cons(xlenter("X"),NIL);
  270.     body = cons(xlenter("X"),NIL);
  271.     body = cons(xlenter("%COPY-STRUCT"),body);
  272.     body = cons(body,NIL);
  273.     setfunction(sym,
  274.         xlclose(sym,s_lambda,args,body,NIL,NIL));
  275.  
  276.     /* restore the stack */
  277.     xlpopn(6);
  278.  
  279.     /* return the structure name */
  280.     return (structname);
  281. }
  282.  
  283. /* xlrdstruct - convert a list to a structure (used by the reader) */
  284. LVAL xlrdstruct(list)
  285.   LVAL list;
  286. {
  287.     LVAL structname,/*sym,*/slotname,expr,last,val; /* not used JKL */
  288.  
  289.     /* protect the new structure */
  290.     xlsave1(expr);
  291.  
  292.     /* get the structure name */
  293.     if (!consp(list) || !symbolp(car(list)))
  294.     xlerror("bad structure initialization list",list);
  295.     structname = car(list);
  296.     list = cdr(list);
  297.  
  298.     /* enter the MAKE-xxx symbol */
  299.     sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
  300.  
  301.     /* initialize the MAKE-xxx function call expression */
  302.     expr = cons(xlenter(buf),NIL);
  303.     last = expr;
  304.  
  305.     /* turn the rest of the initialization list into keyword arguments */
  306.     while (consp(list) && consp(cdr(list))) {
  307.  
  308.     /* get the slot keyword name */
  309.     slotname = car(list);
  310.     if (!symbolp(slotname))
  311.         xlerror("expecting a slot name",slotname);
  312.     sprintf(buf,":%s",getstring(getpname(slotname)));
  313.  
  314.     /* add the slot keyword */
  315.     rplacd(last,cons(xlenter(buf),NIL));
  316.     last = cdr(last);
  317.     list = cdr(list);
  318.  
  319.     /* add the value expression */
  320.     rplacd(last,cons(car(list),NIL));
  321.     last = cdr(last);
  322.     list = cdr(list);
  323.     }
  324.  
  325.     /* make sure all of the initializers were used */
  326.     if (consp(list))
  327.     xlerror("bad structure initialization list",list);
  328.  
  329.     /* invoke the creation function */
  330.     val = xleval(expr);
  331.  
  332.     /* restore the stack */
  333.     xlpop();
  334.  
  335.     /* return the new structure */
  336.     return (val);
  337. }
  338.  
  339. /* xlprstruct - print a structure (used by printer) */
  340. void xlprstruct(fptr,vptr,flag)
  341.   LVAL fptr,vptr; int flag;
  342. {
  343.     LVAL next;
  344.     int i,n;
  345.     xlputc(fptr,'#'); xlputc(fptr,'S'); xlputc(fptr,'(');
  346.     xlprint(fptr,getelement(vptr,0),flag);
  347.     next = xlgetprop(getelement(vptr,0),xlenter("*STRUCT-SLOTS*"));
  348.     for (i = 1, n = getsize(vptr) - 1; i <= n && consp(next); ++i) {
  349.     if (consp(car(next))) { /* should always succeed */
  350.         xlputc(fptr,' ');
  351.         xlprint(fptr,car(car(next)),flag);
  352.         xlputc(fptr,' ');
  353.         xlprint(fptr,getelement(vptr,i),flag);
  354.     }
  355.     next = cdr(next);
  356.     }
  357.     xlputc(fptr,')');
  358. }
  359.  
  360. /* addslot - make the slot access functions */
  361. LOCAL void addslot(slotname,defexpr,slotn,pargs,pbody)
  362.   LVAL slotname,defexpr; int slotn; LVAL *pargs,*pbody;
  363. {
  364.     LVAL sym,args,body,tmp;
  365.     
  366.     /* protect some pointers */
  367.     xlstkcheck(4);
  368.     xlsave(sym);
  369.     xlsave(args);
  370.     xlsave(body);
  371.     xlsave(tmp);
  372.     
  373.     /* construct the update function name */
  374.     sprintf(buf,"%s%s",prefix,getstring(getpname(slotname)));
  375.     sym = xlenter(buf);
  376.     
  377.     /* make the access function */
  378.     args = cons(xlenter("S"),NIL);
  379.     body = cons(cvfixnum((FIXTYPE)slotn),NIL);
  380.     body = cons(xlenter("S"),body);
  381.     body = cons(xlenter("%STRUCT-REF"),body);
  382.     body = cons(body,NIL);
  383.     setfunction(sym,
  384.         xlclose(sym,s_lambda,args,body,NIL,NIL));
  385.  
  386.     /* make the update function */
  387.     args = cons(xlenter("V"),NIL);
  388.     args = cons(xlenter("S"),args);
  389.     body = cons(xlenter("V"),NIL);
  390.     body = cons(cvfixnum((FIXTYPE)slotn),body);
  391.     body = cons(xlenter("S"),body);
  392.     body = cons(xlenter("%STRUCT-SET"),body);
  393.     body = cons(body,NIL);
  394.     xlputprop(sym,
  395.           xlclose(NIL,s_lambda,args,body,NIL,NIL),
  396.           xlenter("*SETF*"));
  397.  
  398.     /* add the slotname to the make-xxx keyword list */
  399.     tmp = cons(defexpr,NIL);
  400.     tmp = cons(slotname,tmp);
  401.     tmp = cons(tmp,NIL);
  402.     if ((args = *pargs) == NIL)
  403.     *pargs = tmp;
  404.     else {
  405.     while (cdr(args) != NIL)
  406.         args = cdr(args);
  407.     rplacd(args,tmp);
  408.     }
  409.     
  410.     /* add the slotname to the %make-xxx argument list */
  411.     tmp = cons(slotname,NIL);
  412.     if ((body = *pbody) == NIL)
  413.     *pbody = tmp;
  414.     else {
  415.     while (cdr(body) != NIL)
  416.         body = cdr(body);
  417.     rplacd(body,tmp);
  418.     }
  419.  
  420.     /* restore the stack */
  421.     xlpopn(4);
  422. }
  423.  
  424. /* updateslot - update a slot definition */
  425. LOCAL void updateslot(args,slotname,defexpr)
  426.   LVAL args,slotname,defexpr;
  427. {
  428.     LVAL tmp;
  429.     for (; consp(args); args = cdr(args))
  430.     if (slotname == car(car(args))) {
  431.         if (defexpr != NIL) {
  432.         xlsave1(tmp);
  433.         tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
  434.         setbody(tmp,cons(defexpr,NIL));
  435.         tmp = cons(tmp,NIL);
  436.         defexpr = tmp;
  437.         xlpop();
  438.         }
  439.         rplaca(cdr(car(args)),defexpr);
  440.         break;
  441.     }
  442.     if (args == NIL)
  443.     xlerror("unknown slot name",slotname);
  444. }
  445.  
  446.